; ORIGINAL: 3dt2.1/examples/rbspline.scm
; $Id: rbspline.scm,v 1.5 1997/04/30 20:24:16 jread Exp $
(require 'cmd)

(define tmp-spline #f)
(define nseg 25)
(define spline-points '())
(define counter 0)
(define XZ-plane (gvector 0 -1 0))
(define Drawing-View #f)
(define last-pos #f)

(define make-spline
  (lambda (list)
    (if (< (position:distance
			(car spline-points) (car (cdr spline-points))) 0.000001)
        (set! spline-points (cdr spline-points)))
    (edge:spline spline-points)
    (set! tmp-spline #f)
    (set! spline-points '())
    (set! last-pos #f)
    (set! counter 0)))

(define (rbspline)
  (begin
    (set! tmp-spline #f)
    (set! spline-points '())
    (set! last-pos #f)
    (set! counter 0)
    (cmd:set `(make-spline
                ,(arg:desc
                   %point
                   '(ui:prompt "Indicate spline points - rt button when done")
                   ( lambda (p)
                     (set! counter (+ counter 1))
                     (if (= counter 1)
                         (begin
                           (env:set-auto-display #f)
                           ; Place first new pos in list twice because
						   ; rbupdate removes one occurrence
                           (set! spline-points (list p p))
                           (rbd:scheme #t
									  ;; First vector holds hook functions
									  (vector
									   #v ;; init
									   spline-start-hook
									   spline-update-hook
									   spline-stop-hook
									   spline-repaint-hook
									   #v ;; position
									   #v ;; end
									   )
									  ;; Second vector data used by hooks
									  (vector #v)))
									   ;;#v ;; tmp-spline
									   ;;#v ;; Drawing-View?
									   ;;#v ;; last-pos)))
                         (if p
                             (if (> (position:distance p last-pos) 0.000001)
                                 (set! spline-points (cons p spline-points)))))
                     (set! last-pos p))
                   (lambda (l)
                     (rbd:remove-type rbd:scheme?)
                     (env:set-auto-display #t)
                     (roll -1)
                     l))))))

;;;;; (draw-spline) ;;;;;
(define draw-spline
  (lambda ()
    (if Drawing-View
        (begin
          (view:set-rb-mode #t Drawing-View)
          (view:draw-polyline
		   (do
			   ((segnum 0 (+ segnum 1))
				(pos-list '()))
			   ((= segnum nseg)
				(set! pos-list (cons (curve:eval-pos tmp-spline 1) pos-list)))
			 (set! pos-list (cons
							 (curve:eval-pos tmp-spline (/ segnum nseg))
							 pos-list)))
		   Drawing-View)
          (view:set-rb-mode #f Drawing-View)))))

;;;;; (undraw-spline) ;;;;;
(define undraw-spline draw-spline)

;;;;; (spline-start-hook) ;;;;;
(define spline-start-hook
  (lambda (rbd pe) (set! Drawing-View (event:view pe))))

;;;;; (spline-update-hook) ;;;;;
(define spline-update-hook
  (lambda (rbd pe)
    (if tmp-spline
        (begin
          (undraw-spline)
          (roll -1)))
    (set! Drawing-View (event:view pe))
    (set! spline-points (cons (pick:position pe) (cdr spline-points)))
    (if (< (position:distance (car spline-points)
							  (cadr spline-points))
		   0.000001)
        (set! spline-points (cdr spline-points)))
    (set! tmp-spline (edge:spline spline-points))
    (draw-spline)))

;;;;; (spline-stop-hook) ;;;;;
(define
  (spline-stop-hook rbd) (undraw-spline) (set! Drawing-View #f))

;;;;; (spline-repaint-hook) ;;;;;
(define (spline-repaint-hook rbd view)
  (if (equal? view Drawing-View) (draw-spline)))

